home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istst / ISTST.MAC.f
Encoding:
Text File  |  1989-03-04  |  72.3 KB  |  1,954 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.5
  3. C---------------------------------------------------------
  4. C
  5. C       I S T S T   -   Program Structurer
  6. C
  7. C       Malcolm Cohen
  8. C       Numerical Algorithms Group, Ltd.
  9. C       Central Office, Oxford.
  10. C       March-July 1986
  11. C
  12.  
  13.         PROGRAM ISTST
  14.  
  15.         LOGICAL TRACE
  16.         PARAMETER (TRACE=.FALSE.)
  17.  
  18. C---------------------------------------------------------
  19. C    TOOLPACK/1    Release: 2.5
  20. C---------------------------------------------------------
  21. C
  22. C  TKLAST = LAST TOKEN NUMBER
  23. C
  24.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  25.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  26.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  27.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  28.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  29.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  30.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  31.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  32.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  33.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  34.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  35.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  36.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  37.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  38.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  39.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  40.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  41.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  42.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  43.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  44.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  45.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  46.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  47.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  48.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  49.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  50.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  51.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  52.  
  53.  
  54.         INTEGER IODTRE,IODSYM,IODCMI,IODCMT,IODOUT,IODPLO,DESCI,DESCO,
  55.      +          PUPTR,PUNUM,I
  56.         INTEGER TREPTH(81),SYMPTH(81),OUTPTH(81),
  57.      +          CMIPTH(81),CMTPTH(81),PLOPTH(81),
  58.      +          NOOPTS(2),DUMMY(2),SYMBOL(8),TEXT(134)
  59.  
  60.         INTEGER OPEN,GETARG,CREATE,ZTKPTI,ZTKGTI,EQUAL,ZYINCI,ZYROOT,
  61.      +          ZYDOWN,ZYNEXT,ZYGPUS
  62.         EXTERNAL OPEN,ERROR,ZINIT,ZQUIT,ZYINSY,ZYINPT,REMARK,GETARG,
  63.      +           CREATE,ZTKPTI,ZTKGTI,ZYINCI,PLOPTF,EQUAL,ZYROOT,
  64.      +           ZYDOWN,ZYNEXT,ZYGPUS,ZCHOUT,ZYGTSY,ZYGTST,PUTLIN,
  65.      +           ZMESS,ZUSCAN,ZFCAPU
  66.  
  67.         DATA NOOPTS/45,129/,DUMMY(1)/129/
  68.  
  69.         CALL ZINIT
  70.  
  71.         PLOPTH(2)=129
  72.         IF (GETARG(1,TREPTH,81).EQ.-100) CALL STARGS(1,TREPTH)
  73.         IF (GETARG(2,SYMPTH,81).EQ.-100) CALL STARGS(2,SYMPTH)
  74.         IF (GETARG(3,CMIPTH,81).EQ.-100) CALL STARGS(3,CMIPTH)
  75.         IF (GETARG(4,CMTPTH,81).EQ.-100) CALL STARGS(4,CMTPTH)
  76.         IF (GETARG(5,OUTPTH,81).EQ.-100) CALL STARGS(5,OUTPTH)
  77.         IF (GETARG(6,PLOPTH,81).EQ.-100) CALL STARGS(6,PLOPTH)
  78.  
  79.         IODTRE=OPEN(TREPTH,0)
  80.         IF (IODTRE.EQ.-1) CALL ERROR('Can''t open parse tree')
  81.         IODSYM=OPEN(SYMPTH,0)
  82.         IF (IODSYM.EQ.-1) CALL ERROR('Can''t open symbol table')
  83.         IODCMI=OPEN(CMIPTH,0)
  84.         IF (IODCMI.EQ.-1) CALL ERROR('Can''t open comment index')
  85.         IODCMT=OPEN(CMTPTH,0)
  86.         IF (IODCMT.EQ.-1) CALL ERROR('Can''t open comment stream')
  87.         IODOUT=CREATE(OUTPTH,1)
  88.         IF (IODOUT.EQ.-1) CALL ERROR('Can''t create output file')
  89.         DESCI=ZTKGTI(2,0,0)
  90.         DESCO=ZTKPTI(0,IODOUT,DESCI)
  91.         IF (PLOPTH(1).NE.129 .AND. EQUAL(PLOPTH,NOOPTS).EQ.-3) THEN
  92.             IODPLO=OPEN(PLOPTH,0)
  93.             IF (IODPLO.EQ.-1) CALL ERROR('Can''t open option file')
  94.             CALL PLOPTF(IODPLO)
  95.         END IF
  96.  
  97.         DO 100 I=7,10
  98.             IF (GETARG(I,TEXT,134).NE.-100) CALL POLOPT(TEXT)
  99.  100    CONTINUE
  100.  
  101.         CALL ZYINPT(IODTRE)
  102.         CALL ZYINSY(IODSYM)
  103.         IF (ZYINCI(IODCMI).NE.-2)
  104.      +      CALL ERROR('Couldn''t 0 comment index')
  105.  
  106.         PUPTR=ZYDOWN(ZYROOT())
  107.         PUNUM=1
  108.  200    CALL ZFCAPU(PUPTR)
  109.         IF (TRACE) THEN
  110.             CALL ZCHOUT('[Processing ',2)
  111.             CALL ZYGTSY(ZYGPUS(PUNUM),SYMBOL)
  112.             CALL ZYGTST(SYMBOL(2),TEXT)
  113.             CALL PUTLIN(TEXT,2)
  114.             CALL ZMESS(']',2)
  115.         END IF
  116.         CALL PROCPU(PUPTR,IODCMT,DESCO,TRACE)
  117.         PUPTR=ZYNEXT(PUPTR)
  118.         PUNUM=PUNUM+1
  119.         IF (PUPTR.NE.0) GOTO 200
  120.         CALL ZUSCAN(TZEOF,0,DUMMY,DESCO)
  121.  
  122.         CALL REMARK('[ISTST Normal Termination]')
  123.         CALL ZQUIT(-2)
  124.  
  125.         END
  126. C ----------------------------------------------------------------------
  127. C
  128. C       S T A R G S   -   Fetch ST command argument from standard input
  129. C
  130.  
  131.         SUBROUTINE STARGS(NUMBER,PATH)
  132.         INTEGER NUMBER,PATH(81)
  133.  
  134.         INTEGER ZGTCMD
  135.         EXTERNAL ZGTCMD,ZPRMPT
  136.  
  137.         INTEGER I,PROMPT(25,6)
  138.  
  139.         SAVE PROMPT
  140.  
  141. C "Input parse tree: "
  142. C "Input symbol table: "
  143. C "Input comment index: "
  144. C "Input comment stream: "
  145. C "Output structured code: "
  146. C "POLISH option file: "
  147.  
  148.         DATA (PROMPT(I,1),I=1,19)/73,110,112,117,116,32,112,
  149.      +97,114,115,101,32,116,114,101,101,58,32,129/,
  150.      +       (PROMPT(I,2),I=1,21)/73,110,112,117,116,32,115,
  151.      +121,109,98,111,108,32,116,97,98,108,101,58,
  152.      +32,129/,
  153.      +       (PROMPT(I,3),I=1,22)/73,110,112,117,116,32,99,
  154.      +111,109,109,101,110,116,32,105,110,100,101,120,
  155.      +58,32,129/
  156.      +       (PROMPT(I,4),I=1,23)/73,110,112,117,116,32,99,
  157.      +111,109,109,101,110,116,32,115,116,114,101,97,
  158.      +109,58,32,129/
  159.      +       (PROMPT(I,5),I=1,25)/79,117,116,112,117,116,32,
  160.      +115,116,114,117,99,116,117,114,101,100,32,99,
  161.      +111,100,101,58,32,129/,
  162.      +       (PROMPT(I,6),I=1,21)/80,79,76,73,83,72,32,
  163.      +111,112,116,105,111,110,32,102,105,108,101,58,
  164.      +32,129/
  165.  
  166.         CALL ZPRMPT(PROMPT(1,NUMBER))
  167.         I=ZGTCMD(PATH,0)
  168.  
  169.         END
  170. C ----------------------------------------------------------------------
  171. C
  172. C       P R O C P U   -   Process a canonicalised program-unit
  173. C
  174.  
  175.         SUBROUTINE PROCPU(PUROOT,IODCMT,DESCO,TRACE)
  176.         INTEGER PUROOT,IODCMT,DESCO
  177.         LOGICAL TRACE,FGOK
  178.  
  179.         INTEGER MFGNOD,MAXCAS
  180.         PARAMETER (MFGNOD=1000,MAXCAS=450)
  181.  
  182.         INTEGER FG(8,MFGNOD),FGSIZE,CASETB(MAXCAS),NCASES,
  183.      +          SYMBOL(8),TEXT(134),STARTN
  184.  
  185.         LOGICAL ZFGRAF
  186.         INTEGER ZYNTYP,ZYPUSY
  187.         EXTERNAL ZYNTYP,ZYPUSY,ZYGTSY,ZYGTST,REMARK,PUTLIN,ZCHOUT,ZMESS,
  188.      +           ZPTINT,ZFGRAF
  189.  
  190.         FGSIZE=0
  191.         NCASES=0
  192.         IF (ZYNTYP(PUROOT).EQ.5) THEN
  193.             CALL FLATTN(PUROOT,IODCMT,DESCO)
  194.         ELSE
  195.             FGOK=ZFGRAF(PUROOT,FG,MFGNOD,FGSIZE,CASETB,MAXCAS,NCASES,
  196.      +                  STARTN,2)
  197.         ENDIF
  198.         IF (FGOK) THEN
  199.             IF (TRACE) THEN
  200.                 CALL ZCHOUT('[Trace: Flow graph size = ',2)
  201.                 CALL ZPTINT(FGSIZE,1,2)
  202.                 CALL ZCHOUT('/',2)
  203.                 CALL ZPTINT(MFGNOD,1,2)
  204.                 CALL ZMESS(']',2)
  205.                 CALL ZCHOUT('[Trace: Case table usage = ',2)
  206.                 CALL ZPTINT(NCASES,1,2)
  207.                 CALL ZCHOUT('/',2)
  208.                 CALL ZPTINT(MAXCAS,1,2)
  209.                 CALL ZMESS(']',2)
  210.             END IF
  211.             CALL STRUCT(PUROOT,FG,FGSIZE,CASETB,MAXCAS,STARTN,IODCMT,
  212.      +                  DESCO,TRACE)
  213.         ELSE
  214.             CALL ZCHOUT('*** Program-unit ',2)
  215.             CALL ZYGTSY(ZYPUSY(PUROOT),SYMBOL)
  216.             CALL ZYGTST(SYMBOL(2),TEXT)
  217.             CALL PUTLIN(TEXT,2)
  218.             CALL ZMESS(' n'//'ot structured',2)
  219.             CALL FLATTN(PUROOT,IODCMT,DESCO)
  220.         END IF
  221.  
  222. CDC Following code is for debugging use only.
  223. CD        PRINT *,'Start node is ',STARTN
  224. CD        PRINT 9000,(J,(FG(I,J),I=1,size_fg_node),J=1,FGSIZE)
  225. CD        IF (NCASES.GT.0) THEN
  226. CD            PRINT *,'Case Table'
  227. CD            PRINT 9010,(I,CASETB(I),I=1,NCASES)
  228. CD        END IF
  229. CD9000    FORMAT(('Node',I4,': ',size_fg_node(I5)))
  230. CD9010    FORMAT((I4,': ',I5))
  231. CD
  232.         END
  233. C ----------------------------------------------------------------------
  234. C
  235. C       S T R U C T   -   Structure a program-unit
  236. C
  237.  
  238.         SUBROUTINE STRUCT(PUROOT,FG,FGSIZE,CASETB,MAXCAS,STARTN,IODCMT,
  239.      +                    DESCO,TRACE)
  240.  
  241.         INTEGER NONEXE,SLC,EXIT,BRANCH,CASE,JUMP,JOIN
  242.         PARAMETER (NONEXE=0,SLC=1,EXIT=2,BRANCH=3,CASE=4,JUMP=5,JOIN=6)
  243.  
  244. C---------------------------------------------------------
  245. C    TOOLPACK/1    Release: 2.5
  246. C---------------------------------------------------------
  247. C
  248. C  TKLAST = LAST TOKEN NUMBER
  249. C
  250.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  251.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  252.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  253.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  254.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  255.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  256.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  257.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  258.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  259.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  260.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  261.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  262.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  263.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  264.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  265.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  266.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  267.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  268.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  269.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  270.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  271.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  272.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  273.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  274.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  275.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  276.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  277.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  278.  
  279.  
  280.         INTEGER PUROOT,FGSIZE,MAXCAS,STARTN,IODCMT,DESCO
  281.         LOGICAL TRACE
  282.         INTEGER FG(8,FGSIZE),CASETB(MAXCAS)
  283.  
  284.         INTEGER STKSIZ
  285.         PARAMETER (STKSIZ=100)
  286.  
  287.         INTEGER PTR,LNUM,I,STACK(3,STKSIZ),SP,CURN,TMP,LOOPL,ENDKD(4),
  288.      +          ERRKD(4),TEXT(134),CONTRL,MAXSP
  289.  
  290. C STACK(1,*)=flowgraph node number being processed at that level
  291. C STACK(2,*)=processing stage (for computed goto) at that level
  292. C STACK(3,*)=value of local variable "LOOPL" (used in loop processing)
  293. C stack pointer SP
  294. C
  295. C LOOPL=loop label; +ve=>repeat-loop (end with GOTO 'LOOPL'),
  296. C                   -ve=>DO-loop (end with '-LOOPL' CONTINUE).
  297. C
  298. C LNUM=last label number generated (user-specified labels are deleted)
  299.  
  300.         INTEGER STSLC,STRPT,STDO,STIF,STXRPT,STIF2,STIF3,NEXTND
  301.  
  302.         INTEGER ZYNEXT,ZYDOWN,ZYNTYP,EQUAL
  303.         EXTERNAL ZYNEXT,ZYDOWN,ZYNTYP,EQUAL,ERROR,YSTMT,ZCHOUT,ZPTINT,
  304.      +           ZMESS
  305.  
  306.         DATA ENDKD/69,78,68,129/,ERRKD/69,82,82,129/
  307.  
  308.         LNUM=0
  309.         MAXSP=0
  310. C
  311. C First, output declaratives, relabel FORMATs, and delabel others.
  312. C
  313.         CALL ODRFDO(PUROOT,IODCMT,DESCO)
  314. C
  315. C And this is where the program really starts
  316. C
  317.         CURN=STARTN
  318.         SP=0
  319.         CONTRL=1
  320. C
  321. C Control Section: loop through here for iteration, sequencing and
  322. C                  recursion control.
  323. C
  324.  100    GOTO (200,300,400,500,1000,600,1500) CONTRL
  325.         CALL ERROR('GETFORM: INTERNAL CALLING SEQUENCE ERROR')
  326. C
  327. C Enter "GETFORM": Perform node-dependent tasks
  328. C
  329.  200    IF (FG(1,CURN).GT.0 .AND. FG(3,CURN).EQ.0) THEN
  330. C SLC or EXIT
  331.             CONTRL=STSLC(FG,FGSIZE,CURN,LNUM,IODCMT,DESCO,STACK,
  332.      +                   STKSIZ,SP,PUROOT)
  333.         ELSE IF (FG(1,CURN).EQ.-1) THEN
  334. C REPEAT
  335.             CONTRL=STRPT(FG,FGSIZE,CURN,DESCO,STACK,STKSIZ,SP,MAXSP,
  336.      +                   LNUM)
  337.         ELSE IF (FG(2,CURN).LT.0) THEN
  338. C CASE
  339.             TMP=-FG(2,CURN)-1
  340.             IF (FG(1,CURN).LT.0) THEN
  341. C simulated case to handle ENTRY points
  342.             ELSE IF (ZYNTYP(FG(1,CURN)).EQ.52) THEN
  343. C   - part 1: fix the statement up so the label refs are correct
  344.                 PTR=ZYDOWN(FG(1,CURN))
  345.                 IF (ZYNTYP(PTR).EQ.115) PTR=ZYNEXT(PTR)
  346.                 PTR=ZYDOWN(PTR)
  347.                 DO 250 I=1-FG(3,CURN),TMP-FG(3,CURN)
  348.                     CALL MKLREF(FG,FGSIZE,CASETB(I),LNUM,PTR)
  349.                     PTR=ZYNEXT(PTR)
  350.  250            CONTINUE
  351.             ELSE IF (ZYNTYP(FG(1,CURN)).EQ.55) THEN
  352.                 IF (TMP.NE.2) CALL ERROR('STRUCP: INVALID ARITHIF')
  353.                 PTR=ZYDOWN(FG(1,CURN))
  354.                 IF (ZYNTYP(PTR).EQ.115) PTR=ZYNEXT(PTR)
  355.                 PTR=ZYNEXT(PTR)
  356.                 DO 255 I=-FG(3,CURN),TMP-FG(3,CURN)
  357.                     CALL MKLREF(FG,FGSIZE,CASETB(I),LNUM,PTR)
  358.                     PTR=ZYNEXT(PTR)
  359.  255            CONTINUE
  360.             ELSE IF (ZYNTYP(FG(1,CURN)).EQ.82) THEN
  361.                 PTR=ZYDOWN(FG(1,CURN))
  362.                 DO 258 I=1-FG(3,CURN),TMP-FG(3,CURN)
  363.  257                PTR=ZYNEXT(PTR)
  364.                     IF (ZYNTYP(PTR).NE.116) GOTO 257
  365.                     CALL MKLREF(FG,FGSIZE,CASETB(I),LNUM,PTR)
  366.  258            CONTINUE
  367.             ELSE
  368.                 PTR=ZYDOWN(FG(1,CURN))
  369.                 I=1-FG(3,CURN)
  370.  260            IF (ZYNTYP(PTR).NE.68) THEN
  371.                     PTR=ZYNEXT(PTR)
  372.                     GOTO 260
  373.                 END IF
  374.                 PTR=ZYDOWN(PTR)
  375.  270            IF (ZYNTYP(PTR).EQ.69) THEN
  376.                     CALL ZYGTST(-ZYDOWN(ZYDOWN(PTR)),TEXT)
  377.                     IF (EQUAL(TEXT,ENDKD).EQ.-2 .OR.
  378.      +                  EQUAL(TEXT,ERRKD).EQ.-2) THEN
  379.                         CALL MKLREF(FG,FGSIZE,CASETB(I),LNUM,
  380.      +                              ZYNEXT(ZYDOWN(PTR)))
  381.                         I=I+1
  382.                     END IF
  383.                 END IF
  384.                 PTR=ZYNEXT(PTR)
  385.                 IF (PTR.NE.0) GOTO 270
  386.             END IF
  387. C   - Part 2: Output the modified statement
  388.             IF (FG(1,CURN).GT.0) THEN
  389.                 CALL COMMNT(FG(1,CURN),IODCMT,DESCO)
  390.                 CALL YSTMT(FG(1,CURN),DESCO)
  391.             END IF
  392. C   - Part 3: Stack call so we stack the followers later
  393.             CALL GFPUSH(STACK,STKSIZ,SP,CURN,5,LOOPL,MAXSP)
  394. C   - Part 4: Stack calls to process the descendents in order
  395. C             (being careful not to stack two copies of one node!)
  396. C             (also don't stack calls for backward pointers!)
  397.             DO 280 I=TMP-FG(3,CURN),-FG(3,CURN),-1
  398.                 IF (FG(8,CASETB(I)).EQ.0 .AND.
  399.      +              FG(4,CASETB(I)).GT.FG(4,CURN)) THEN
  400.                     CALL GFPUSH(STACK,STKSIZ,SP,CASETB(I),1,LOOPL,MAXSP)
  401.                     FG(8,CASETB(I))=-1
  402.                 END IF
  403.  280        CONTINUE
  404.             DO 290 I=TMP-FG(3,CURN),-FG(3,CURN),-1
  405.                 IF (FG(8,CASETB(I)).EQ.-1)
  406.      +              FG(8,CASETB(I))=0
  407.  290        CONTINUE
  408. C   - Part 5: Fixup default control flow
  409.             IF (FG(1,CURN).GT.0) THEN
  410.               IF (ZYNTYP(FG(1,CURN)).NE.55 .AND.
  411.      +          NEXTND(FG,FGSIZE,-1,STACK,STKSIZ,SP).NE.
  412.      +          CASETB(-FG(3,CURN)))
  413.      +          CALL GOTOX(FG,FGSIZE,CASETB(-FG(3,CURN)),
  414.      +                     LNUM,DESCO)
  415.             ENDIF
  416. C   - Part 6: Return from GETFORM
  417.             CONTRL=7
  418.         ELSE IF (ZYNTYP(FG(1,CURN)).EQ.61) THEN
  419. C IF (actually DO)
  420.             CONTRL=STDO(FG,FGSIZE,CURN,LNUM,IODCMT,DESCO,STACK,STKSIZ,
  421.      +                  SP,MAXSP)
  422.         ELSE
  423. C IF (not a DO)
  424.             CONTRL=STIF(FG,FGSIZE,CURN,IODCMT,DESCO,STACK,STKSIZ,SP,
  425.      +                  LNUM,MAXSP)
  426.         END IF
  427.         GOTO 100
  428. C
  429. C END OF REPEAT LOOP
  430. C
  431.  300    CONTRL=STXRPT(FG,FGSIZE,CURN,LOOPL,DESCO,STACK,STKSIZ,SP,LNUM,
  432.      +                MAXSP)
  433.         GOTO 100
  434. C
  435. C MIDDLE OF IF TEST
  436. C
  437.  400    CONTRL=STIF2(FG,FGSIZE,CURN,DESCO,STACK,STKSIZ,SP,LNUM,
  438.      +                  MAXSP)
  439.         GOTO 100
  440. C
  441. C END OF IF BLOCK
  442. C
  443.  500    CONTRL=STIF3(DESCO)
  444.         GOTO 100
  445. C
  446. C TRANSFER OF CONTROL (SINGLETON REACH SET)
  447. C
  448.  600    CALL GOTOX(FG,FGSIZE,CURN,LNUM,DESCO)
  449.         CONTRL=7
  450.         GOTO 100
  451. C
  452. C Final part of GETFORM: stack calls to do all "follow" nodes
  453. C
  454. 1000    CALL STKFOL(FG,FGSIZE,CURN,STACK,STKSIZ,SP,MAXSP)
  455. C
  456. C End of "GETFORM" -- pop call stack and go to it.
  457. C
  458. 1500    IF (SP.GT.0) THEN
  459.             CURN=STACK(1,SP)
  460.             CONTRL=STACK(2,SP)
  461.             LOOPL=STACK(3,SP)
  462.             SP=SP-1
  463.             GOTO 100
  464.         END IF
  465. C
  466. C If we have reached here then we have finished
  467. C
  468.         IF (TRACE) THEN
  469.             CALL ZCHOUT('[Trace: STRUCT stack usage = ',2)
  470.             CALL ZPTINT(MAXSP,1,2)
  471.             CALL ZMESS(']',2)
  472.         END IF
  473.  
  474.         END
  475. C ----------------------------------------------------------------------
  476. C
  477. C       O D R F D O   -   Output Declaratives, relabel Formats and
  478. C                         Delabel Others.
  479. C
  480.  
  481.         SUBROUTINE ODRFDO(PUPTR,IODCMT,DESCO)
  482.         INTEGER PUPTR,IODCMT,DESCO
  483.  
  484.         INTEGER NONEXE,EXE
  485.         PARAMETER (NONEXE=0,EXE=1)
  486.  
  487.         INTEGER STTYPE(132),STPTR,PTR,I,LTEXT(8),LNUM
  488.  
  489.         SAVE STTYPE
  490.  
  491.         INTEGER ZYDOWN,ZYNTYP,ZYNEXT,ITOC,ZYASTR
  492.         EXTERNAL ZYDOWN,ZYNTYP,ZYNEXT,ITOC,ZYASTR,ZYSATT,ZYDELT,YSTMT
  493.  
  494.         DATA STTYPE(7),STTYPE(8),STTYPE(16),
  495.      +       STTYPE(20),STTYPE(24),STTYPE(26),
  496.      +       STTYPE(30),STTYPE(35),STTYPE(37),
  497.      +       STTYPE(38),STTYPE(39),STTYPE(41),
  498.      +       STTYPE(78),STTYPE(121)
  499.      +       /14*NONEXE/
  500.         DATA STTYPE(18),STTYPE(49),STTYPE(131),
  501.      +       STTYPE(63),STTYPE(64),STTYPE(67),
  502.      +       STTYPE(82),STTYPE(50),STTYPE(6),
  503.      +       STTYPE(65),STTYPE(66),STTYPE(72),
  504.      +       STTYPE(73),STTYPE(74),STTYPE(75),
  505.      +       STTYPE(52),STTYPE(53),STTYPE(55),
  506.      +       STTYPE(76),STTYPE(77),STTYPE(51),
  507.      +       STTYPE(56),STTYPE(57),STTYPE(58),
  508.      +       STTYPE(59),STTYPE(60),STTYPE(62),
  509.      +       STTYPE(83),STTYPE(61),STTYPE(132)
  510.      +       /30*EXE/
  511.  
  512.         STPTR=ZYDOWN(PUPTR)
  513.         LNUM=9000
  514.  100    PTR=ZYDOWN(STPTR)
  515.         IF (ZYNTYP(STPTR).EQ.78) THEN
  516. C Number FORMAT starting from 9000 (we don't care a whit about the
  517. C resultant destruction of the symbol table) in steps of 10.
  518.             I=ITOC(LNUM,LTEXT,7)
  519.             LNUM=LNUM+10
  520.             CALL ZYSATT(-ZYDOWN(PTR),2,ZYASTR(LTEXT))
  521.         ELSE
  522. C Delete all other labels in the program-unit as we will create our own
  523.             IF (PTR.NE.0) THEN
  524.                 IF (ZYNTYP(PTR).EQ.115) CALL ZYDELT(PTR)
  525.             END IF
  526. C Output non-executable non-FORMAT statements (declarations).
  527.             IF (STTYPE(ZYNTYP(STPTR)).EQ.NONEXE) THEN
  528.                 CALL COMMNT(STPTR,IODCMT,DESCO)
  529.                 CALL YSTMT(STPTR,DESCO)
  530.             END IF
  531.         END IF
  532.         STPTR=ZYNEXT(STPTR)
  533.         IF (STPTR.NE.0) GOTO 100
  534.  
  535.         END
  536. C ----------------------------------------------------------------------
  537. C
  538. C       G F P U S H   -   Push stack frame for GETFORM
  539. C
  540.  
  541.         SUBROUTINE GFPUSH(STACK,STKSIZ,SP,CURN,JUMP,LOOP,MAXSP)
  542.         INTEGER STKSIZ,SP,CURN,JUMP,LOOP,MAXSP
  543.         INTEGER STACK(3,STKSIZ)
  544.  
  545.         EXTERNAL ERROR
  546.  
  547.         IF (SP.EQ.STKSIZ) CALL ERROR('STRUCT stack overflow')
  548.         SP=SP+1
  549.         MAXSP=MAX(SP,MAXSP)
  550.         STACK(1,SP)=CURN
  551.         STACK(2,SP)=JUMP
  552.         STACK(3,SP)=LOOP
  553.  
  554.         END
  555. C ----------------------------------------------------------------------
  556. C
  557. C       S T S L C   -   Structure: SLC node
  558. C
  559.  
  560.         INTEGER FUNCTION STSLC(FG,FGSIZE,CURN,LNUM,IODCMT,DESCO,STACK,
  561.      +                         STKSIZ,SP,PUROOT)
  562.         INTEGER CURN,FGSIZE,LNUM,IODCMT,DESCO,STKSIZ,SP,PUROOT
  563.         INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
  564.  
  565.         INTEGER NEXTND
  566.  
  567.         INTEGER ZYNTYP,ZYDOWN
  568.         EXTERNAL ZYNTYP,ZYDOWN,ZYCHNT,YSTMT,REMARK
  569.  
  570.         CALL COMMNT(FG(1,CURN),IODCMT,DESCO)
  571. C if (END statement) then output FORMAT statements first, and also
  572. C check for dead code being eliminated...
  573.         IF (ZYNTYP(FG(1,CURN)).EQ.6) THEN
  574.             CALL OUTFMT(PUROOT,IODCMT,DESCO)
  575.             CALL CKDEAD(FG,FGSIZE,PUROOT,IODCMT,DESCO)
  576.         END IF
  577.         IF (ZYNTYP(FG(1,CURN)).NE.131) THEN
  578.             CALL YSTMT(FG(1,CURN),DESCO)
  579.         ELSE IF (ZYDOWN(FG(1,CURN)).NE.0) THEN
  580.             CALL ZYCHNT(FG(1,CURN),62)
  581.             CALL YSTMT(FG(1,CURN),DESCO)
  582.         END IF
  583.         IF (NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).NE.
  584.      +      FG(2,CURN) .AND.
  585.      +      ZYNTYP(FG(1,CURN)).NE.83 .AND.
  586.      +      ZYNTYP(FG(1,CURN)).NE.63) THEN
  587. C This does "FIXCONTROL" on the fly (the only way it should be done!)
  588.             IF (ZYNTYP(FG(1,CURN)).EQ.6) THEN
  589.                 CALL REMARK(
  590.      +'Internal Error: END statement is in the wrong place')
  591.             ELSE IF (FG(2,CURN).NE.0) THEN
  592.                 CALL GOTOX(FG,FGSIZE,FG(2,CURN),LNUM,DESCO)
  593.             END IF
  594.         END IF
  595.         STSLC=5
  596.  
  597.         END
  598. C ----------------------------------------------------------------------
  599. C
  600. C       S T R P T   -   Structure: REPEAT node
  601. C
  602.  
  603.         INTEGER FUNCTION STRPT(FG,FGSIZE,CURN,DESCO,STACK,STKSIZ,SP,
  604.      +                         MAXSP,LNUM)
  605.         INTEGER FGSIZE,CURN,DESCO,STKSIZ,SP,MAXSP,LNUM
  606.         INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
  607.  
  608. C---------------------------------------------------------
  609. C    TOOLPACK/1    Release: 2.5
  610. C---------------------------------------------------------
  611. C
  612. C  TKLAST = LAST TOKEN NUMBER
  613. C
  614.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  615.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  616.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  617.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  618.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  619.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  620.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  621.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  622.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  623.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  624.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  625.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  626.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  627.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  628.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  629.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  630.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  631.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  632.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  633.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  634.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  635.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  636.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  637.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  638.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  639.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  640.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  641.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  642.  
  643.  
  644.         INTEGER TMP,LOOPL,LTEXT(8),I
  645.  
  646.         INTEGER ITOC,ZYNTYP
  647.         EXTERNAL ITOC,ZYNTYP,ZUSCAN
  648.  
  649.         TMP=FG(1,FG(2,CURN))
  650.         IF (TMP.GT.0) THEN
  651.             IF (ZYNTYP(TMP).NE.61) TMP=-1
  652.         END IF
  653.         IF (FG(3,CURN).EQ.0) THEN
  654.             LNUM=LNUM+10
  655.             IF (LNUM.EQ.9000) LNUM=90000
  656.             IF (TMP.LE.0) THEN
  657.                 I=ITOC(LNUM,LTEXT,7)
  658.                 CALL ZUSCAN(TDCNST,I,LTEXT,DESCO)
  659.                 LTEXT(1)=129
  660.                 CALL ZUSCAN(TCONTI,0,LTEXT,DESCO)
  661.                 CALL ZUSCAN(TZEOS,0,LTEXT,DESCO)
  662.                 LOOPL=LNUM
  663.             ELSE
  664.                 LOOPL=-LNUM
  665.             END IF
  666.             FG(3,CURN)=LOOPL
  667.         ELSE
  668. C label already assigned to this repeat - use it
  669.             LOOPL=FG(3,CURN)
  670.             IF (LOOPL.GT.0) THEN
  671.                 I=ITOC(LOOPL,LTEXT,7)
  672.                 CALL ZUSCAN(TDCNST,I,LTEXT,DESCO)
  673.                 LTEXT(1)=129
  674.                 CALL ZUSCAN(TCONTI,0,LTEXT,DESCO)
  675.                 CALL ZUSCAN(TZEOS,0,LTEXT,DESCO)
  676.             END IF
  677.         END IF
  678. C If "q" not in any follow set then make a recursive call
  679.         IF (FG(8,FG(2,CURN)).EQ.0) THEN
  680.             CALL GFPUSH(STACK,STKSIZ,SP,CURN,2,LOOPL,MAXSP)
  681.             CURN=FG(2,CURN)
  682.             STRPT=1
  683.         ELSE
  684.             STRPT=2
  685.         END IF
  686.  
  687.         END
  688. C ----------------------------------------------------------------------
  689. C
  690. C       S T D O   -   Structure: DO statement node
  691. C
  692.  
  693.         INTEGER FUNCTION STDO(FG,FGSIZE,CURN,LNUM,IODCMT,DESCO,STACK,
  694.      +                        STKSIZ,SP,MAXSP)
  695.         INTEGER FGSIZE,CURN,LNUM,IODCMT,DESCO,STKSIZ,MAXSP,SP
  696.         INTEGER FG(8,FGSIZE),STACK(MAXSP)
  697.  
  698.         INTEGER LTEXT(8),I,PTR
  699.  
  700.         INTEGER ITOC,ZYDOWN,ZYNTYP,ZYNEXT,ZYASYM,ZYASTR
  701.         EXTERNAL ITOC,ZYDOWN,ZYNTYP,ZYNEXT,ZYASYM,ZYASTR,ERROR,ZYCHDN,
  702.      +           YSTMT
  703.  
  704. C Check for DO which is not a loop
  705.         IF (FG(4,FG(2,CURN)).LT.FG(4,CURN).OR.
  706.      +      FG(8,FG(2,CURN)).NE.0) THEN
  707.             CALL ERROUT('Warning: DO non-loop found',FG(1,CURN))
  708.             LNUM=LNUM+10
  709.             IF (LNUM.EQ.9000) LNUM=90000
  710.         END IF
  711.         I=ITOC(LNUM,LTEXT,7)
  712.         PTR=ZYDOWN(FG(1,CURN))
  713.         IF (ZYNTYP(PTR).EQ.115) PTR=ZYNEXT(PTR)
  714.         IF (ZYNTYP(PTR).NE.116) CALL ERROR('OOPS!')
  715.         CALL ZYCHDN(PTR,-ZYASYM(ZYASTR(LTEXT),1,1))
  716.         CALL COMMNT(FG(1,CURN),IODCMT,DESCO)
  717.         CALL YSTMT(FG(1,CURN),DESCO)
  718. C Non-looping DO?
  719.         IF (FG(4,FG(2,CURN)).LT.FG(4,CURN).OR.
  720.      +      FG(8,FG(2,CURN)).NE.0) THEN
  721.             CALL GFPUSH(STACK,STKSIZ,SP,CURN,2,-LNUM,MAXSP)
  722.             IF (FG(8,FG(2,CURN)).EQ.0) THEN
  723.                 CURN=FG(2,CURN)
  724.                 STDO=1
  725.             ELSE
  726.                 CALL GOTOX(FG,FGSIZE,FG(2,CURN),LNUM,DESCO)
  727.                 STDO=7
  728.             END IF
  729.         ELSE
  730. C (GFPUSH done in repeat node processing already)
  731.             CURN=FG(2,CURN)
  732.             STDO=1
  733.         END IF
  734.  
  735.         END
  736. C ----------------------------------------------------------------------
  737. C
  738. C       S T I F   -   Structure: an IF node
  739. C
  740.  
  741.         INTEGER FUNCTION STIF(FG,FGSIZE,CURN,IODCMT,DESCO,STACK,STKSIZ,
  742.      +                        SP,LNUM,MAXSP)
  743.         INTEGER FGSIZE,CURN,IODCMT,DESCO,STKSIZ,SP,LNUM,MAXSP
  744.         INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
  745.  
  746. C---------------------------------------------------------
  747. C    TOOLPACK/1    Release: 2.5
  748. C---------------------------------------------------------
  749. C
  750. C  TKLAST = LAST TOKEN NUMBER
  751. C
  752.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  753.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  754.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  755.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  756.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  757.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  758.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  759.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  760.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  761.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  762.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  763.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  764.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  765.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  766.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  767.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  768.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  769.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  770.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  771.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  772.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  773.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  774.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  775.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  776.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  777.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  778.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  779.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  780.  
  781.  
  782.         LOGICAL LOGIFS
  783.         PARAMETER (LOGIFS=.TRUE.)
  784.  
  785.         INTEGER TMP,PTR,DUMMY(2)
  786.         LOGICAL LTMP,LTMP2
  787.  
  788.         SAVE DUMMY
  789.  
  790.         INTEGER NEXTND,FOLLOW
  791.  
  792.         INTEGER ZYNTYP,ZYDOWN,ZYNEXT
  793.         EXTERNAL ZYNTYP,ZYDOWN,ZYNEXT,ZYCHNT,YLEAF,ZUSCAN,YEXPR,YSTMT
  794.  
  795.         DATA DUMMY/129,129/
  796.  
  797.         STIF=5
  798.         IF (ZYNTYP(FG(1,CURN)).NE.132+1) THEN
  799.             CALL ZYCHNT(FG(1,CURN),57)
  800.             IF (FOLLOW(FG,FGSIZE,CURN).EQ.0)
  801.      +          CALL REACH(FG,FGSIZE,CURN,
  802.      +                     NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP),
  803.      +                    STACK,STKSIZ,SP,MAXSP)
  804.         ELSE
  805.             CALL ZYCHNT(FG(1,CURN),58)
  806.         END IF
  807. C Simplify logical expressions by removing extra parentheses around them
  808.         PTR=ZYDOWN(FG(1,CURN))
  809.  100    IF (ZYNTYP(PTR).EQ.101) THEN
  810.             TMP=ZYDOWN(PTR)
  811.             CALL ZYREPL(PTR,TMP)
  812.             PTR=TMP
  813.             GOTO 100
  814.         END IF
  815. C Check for logical expression beginning with .NOT. and invert it if so
  816. C (so we can simplify logical expressions we wouldn't touch otherwise
  817.         IF (ZYNTYP(ZYDOWN(FG(1,CURN))).EQ.88)
  818.      +      CALL INVERT(FG,FGSIZE,CURN)
  819. C Test for 'ifless else' and turn it into an 'elseless if'
  820.         IF (NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).EQ.
  821.      +      FG(2,CURN)) THEN
  822. C But not if both ifless and elseless
  823.             IF (FG(2,CURN).NE.FG(3,CURN)) THEN
  824.                 CALL INVERT(FG,FGSIZE,CURN)
  825.             ELSE
  826.                 CALL ERROUT('Warning: IF stmt has null effect',
  827.      +                      FG(1,CURN))
  828.             END IF
  829. C Also check for possibility of an ELSEIF construction
  830. C (but not if it is an elseless if)
  831.         ELSE IF (NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).NE.
  832.      +           FG(3,CURN) .AND.
  833.      +           FG(4,FG(2,CURN)).GE.FG(4,CURN)
  834.      +           .AND. FG(8,FG(2,CURN)).EQ.0) THEN
  835. C Set LTMP == ELSEIF should be generated if the arcs are reversed
  836. C Set LTMP2 == ELSEIF should be generated anyway
  837. C (only reverse arcs if it improves things, not just for fun!)
  838.             LTMP=FG(2,FG(2,CURN)).GT.0 .AND.
  839.      +           FG(3,FG(2,CURN)).GT.0 .AND.
  840.      +           FOLLOW(FG,FGSIZE,FG(2,CURN)).EQ.0
  841.             IF (LTMP)
  842.      +          LTMP=ZYNTYP(FG(1,FG(2,CURN))).NE.61
  843.             LTMP2=FG(4,FG(3,CURN)).GT.FG(4,CURN)
  844.      +            .AND. FG(8,FG(3,CURN)).EQ.0
  845.             IF (LTMP2)
  846.      +          LTMP2=FG(2,FG(3,CURN)).GT.0 .AND.
  847.      +                FG(3,FG(3,CURN)).GT.0 .AND.
  848.      +                FOLLOW(FG,FGSIZE,FG(3,CURN)).EQ.0
  849.             IF (LTMP2)
  850.      +          LTMP2=ZYNTYP(FG(1,FG(3,CURN))).NE.61
  851.  
  852.             IF (LTMP .AND. .NOT.LTMP2) CALL INVERT(FG,FGSIZE,CURN)
  853.         END IF
  854. C If it is an elseless if ... and the if part is not nested inside
  855. C the if ... i.e. it will become an if-goto ... make it a logical
  856. C if-goto not the clumsy if-then goto end-if.
  857. C P.S. Make sure not an ELSEIF though since we can't do it then...
  858.         IF (NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).EQ.
  859.      +      FG(3,CURN) .AND.
  860.      +      ZYNTYP(FG(1,CURN)).EQ.57 .AND.
  861.      +      (FG(8,FG(2,CURN)).NE.0 .OR.
  862.      +      FG(4,FG(2,CURN)).LE.FG(4,CURN)))
  863.      +  THEN
  864.             CALL COMMNT(FG(1,CURN),IODCMT,DESCO)
  865. C Also, this effectively makes this into an slc so
  866.             PTR=ZYDOWN(FG(1,CURN))
  867.             IF (ZYNTYP(PTR).EQ.115) THEN
  868.                 CALL YLEAF(PTR,DESCO)
  869.                 PTR=ZYNEXT(PTR)
  870.             END IF
  871.             CALL ZUSCAN(TIF,0,DUMMY,DESCO)
  872.             CALL ZUSCAN(TLPARN,0,DUMMY,DESCO)
  873.             CALL YEXPR(PTR,DESCO)
  874.             CALL ZUSCAN(TRPARN,0,DUMMY,DESCO)
  875.             CALL GOTOX(FG,FGSIZE,FG(2,CURN),LNUM,DESCO)
  876.         ELSE IF (LOGIFS .AND.
  877.      +           NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).EQ.
  878.      +           FG(3,CURN) .AND.
  879.      +           ZYNTYP(FG(1,CURN)).EQ.57 .AND.
  880.      +           FG(2,FG(2,CURN)).EQ.FG(3,CURN)
  881.      +           .AND. FG(3,FG(2,CURN)).EQ.0 .AND.
  882.      +           FG(7,FG(2,CURN)).EQ.1) THEN
  883. C Produce logical IF but .. check for only a comment as consequence
  884.             CALL COMMNT(FG(1,CURN),IODCMT,DESCO)
  885.             IF (FG(1,FG(2,CURN)).LE.0)
  886.      +          CALL ERROR('INVALID IF STATEMENT')
  887.             IF (ZYNTYP(FG(1,FG(2,CURN))).NE.131)
  888.      +          CALL COMMNT(FG(1,FG(2,CURN)),IODCMT,DESCO)
  889.             PTR=ZYDOWN(FG(1,CURN))
  890.             IF (ZYNTYP(PTR).EQ.115) THEN
  891.                 CALL YLEAF(PTR,DESCO)
  892.                 PTR=ZYNEXT(PTR)
  893.             END IF
  894.             CALL ZUSCAN(TIF,0,DUMMY,DESCO)
  895.             CALL ZUSCAN(TLPARN,0,DUMMY,DESCO)
  896.             CALL YEXPR(PTR,DESCO)
  897.             CALL ZUSCAN(TRPARN,0,DUMMY,DESCO)
  898.             IF (ZYNTYP(FG(1,FG(2,CURN))).NE.131)
  899.      +      THEN
  900.                 CALL YSTMT(FG(1,FG(2,CURN)),DESCO)
  901.             ELSE
  902.                 CALL ZUSCAN(TTHEN,0,DUMMY,DESCO)
  903.                 CALL ZUSCAN(TZEOS,0,DUMMY,DESCO)
  904.                 CALL COMMNT(FG(1,FG(2,CURN)),IODCMT,DESCO)
  905.                 CALL ZUSCAN(TENDIF,0,DUMMY,DESCO)
  906.                 CALL ZUSCAN(TZEOS,0,DUMMY,DESCO)
  907.                 CALL ERROUT('Warning: IF consequence is a comment',
  908.      +                      FG(1,CURN))
  909.             END IF
  910.         ELSE
  911.             CALL COMMNT(FG(1,CURN),IODCMT,DESCO)
  912.             CALL YSTMT(FG(1,CURN),DESCO)
  913.             IF (FG(4,FG(2,CURN)).GE.FG(4,CURN)
  914.      +          .AND. FG(8,FG(2,CURN)).EQ.0) THEN
  915.                 CALL GFPUSH(STACK,STKSIZ,SP,CURN,3,0,MAXSP)
  916.                 CURN=FG(2,CURN)
  917.                 STIF=1
  918.             ELSE
  919.                 IF (NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).NE.
  920.      +              FG(2,CURN)) THEN
  921. C This does "FIXCONTROL" on the fly (the only way it should be done!)
  922.                     CALL GOTOX(FG,FGSIZE,FG(2,CURN),LNUM,
  923.      +                         DESCO)
  924.                 END IF
  925.                 STIF=3
  926.             END IF
  927.         END IF
  928.  
  929.         END
  930. C ----------------------------------------------------------------------
  931. C
  932. C       I N V E R T   -   Invert the form of an IF, preserving semantics
  933. C
  934.  
  935.         SUBROUTINE INVERT(FG,FGSIZE,CURN)
  936.         INTEGER FGSIZE,CURN
  937.         INTEGER FG(8,FGSIZE)
  938.  
  939.         INTEGER TMP
  940.  
  941.         INTEGER ZYDOWN,ZYNTYP,ZYNEXT
  942.         EXTERNAL ZYDOWN,ZYNTYP,ZYNEXT
  943.  
  944. C --Found one, swap the outarcs
  945.         TMP=FG(2,CURN)
  946.         FG(2,CURN)=FG(3,CURN)
  947.         FG(3,CURN)=TMP
  948. C --Now invert the condition
  949.         TMP=ZYDOWN(FG(1,CURN))
  950.         IF (ZYNTYP(TMP).EQ.115) TMP=ZYNEXT(TMP)
  951.         CALL INVCON(TMP)
  952.  
  953.         END
  954. C ----------------------------------------------------------------------
  955. C
  956. C       S T X R P T   -   Structure: End a repeat loop
  957. C
  958.  
  959.         INTEGER FUNCTION STXRPT(FG,FGSIZE,CURN,LOOPL,DESCO,STACK,STKSIZ,
  960.      +                          SP,LNUM,MAXSP)
  961.         INTEGER FGSIZE,CURN,LOOPL,DESCO,STKSIZ,SP,LNUM,MAXSP
  962.         INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
  963.  
  964. C---------------------------------------------------------
  965. C    TOOLPACK/1    Release: 2.5
  966. C---------------------------------------------------------
  967. C
  968. C  TKLAST = LAST TOKEN NUMBER
  969. C
  970.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  971.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  972.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  973.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  974.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  975.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  976.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  977.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  978.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  979.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  980.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  981.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  982.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  983.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  984.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  985.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  986.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  987.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  988.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  989.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  990.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  991.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  992.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  993.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  994.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  995.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  996.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  997.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  998.  
  999.  
  1000.         INTEGER LTEXT(8),I
  1001.  
  1002.         INTEGER NEXTND
  1003.  
  1004.         INTEGER ITOC
  1005.         EXTERNAL ITOC,ZUSCAN
  1006.  
  1007.         STXRPT=5
  1008.         IF (LOOPL.LT.0) THEN
  1009. C Only terminate DO-loops; force explicit control xfers for others
  1010.             I=ITOC(-LOOPL,LTEXT,7)
  1011.             CALL ZUSCAN(TDCNST,I,LTEXT,DESCO)
  1012.             LTEXT(1)=129
  1013.             CALL ZUSCAN(TCONTI,0,LTEXT,DESCO)
  1014.             CALL ZUSCAN(TZEOS,0,LTEXT,DESCO)
  1015. C Fixup control flow if necessary
  1016. C Check for non-looping DO
  1017.             IF (FG(1,CURN).NE.-1) THEN
  1018.                 IF (FG(4,FG(3,CURN)).GE.
  1019.      +              FG(4,CURN) .AND.
  1020.      +              FG(8,FG(3,CURN)).EQ.0) THEN
  1021. C ... stack followers because we handle the false outarc now.
  1022. C (this is equivalent to handling the false outarc recursively)
  1023.                     CALL STKFOL(FG,FGSIZE,CURN,STACK,STKSIZ,SP,MAXSP)
  1024.                     CURN=FG(3,CURN)
  1025.                     STXRPT=1
  1026.                 ELSE IF (NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).NE.
  1027.      +                   FG(3,CURN)) THEN
  1028.                     CALL GOTOX(FG,FGSIZE,FG(3,CURN),LNUM,DESCO)
  1029.                 END IF
  1030.             ELSE IF (FG(3,FG(2,CURN)).NE.
  1031.      +               NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP)) THEN
  1032.                 CALL GOTOX(FG,FGSIZE,FG(3,FG(2,CURN)),
  1033.      +                     LNUM,DESCO)
  1034.             END IF
  1035.         END IF
  1036.  
  1037.         END
  1038. C ----------------------------------------------------------------------
  1039. C
  1040. C       S T I F 2   -   Structure: IF node part 2 (else clause)
  1041. C
  1042.  
  1043.         INTEGER FUNCTION STIF2(FG,FGSIZE,CURN,DESCO,STACK,STKSIZ,SP,
  1044.      +                         LNUM,MAXSP)
  1045.         INTEGER FGSIZE,CURN,DESCO,STKSIZ,SP,LNUM,MAXSP
  1046.         INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
  1047.  
  1048. C---------------------------------------------------------
  1049. C    TOOLPACK/1    Release: 2.5
  1050. C---------------------------------------------------------
  1051. C
  1052. C  TKLAST = LAST TOKEN NUMBER
  1053. C
  1054.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  1055.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  1056.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  1057.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  1058.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  1059.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  1060.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  1061.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  1062.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  1063.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  1064.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  1065.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  1066.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  1067.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  1068.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  1069.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  1070.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  1071.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  1072.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  1073.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  1074.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  1075.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  1076.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  1077.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  1078.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  1079.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  1080.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  1081.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  1082.  
  1083.  
  1084.         INTEGER DUMMY(2)
  1085.         LOGICAL LTMP
  1086.  
  1087.         SAVE DUMMY
  1088.  
  1089.         INTEGER NEXTND,FOLLOW
  1090.  
  1091.         INTEGER ZYNTYP
  1092.         EXTERNAL ZYNTYP,ZYCHNT,ZUSCAN
  1093.  
  1094.         DATA DUMMY/129,129/
  1095.  
  1096.         STIF2=4
  1097.         IF (FG(4,FG(3,CURN)).GE.FG(4,CURN)
  1098.      +          .AND. FG(8,FG(3,CURN)).EQ.0) THEN
  1099. C Check for ELSEIF possibility:
  1100. C   if next node is an IF (not a DO) and its follow set is null
  1101.             LTMP=FG(2,FG(3,CURN)).GT.0 .AND.
  1102.      +           FG(3,FG(3,CURN)).GT.0 .AND.
  1103.      +           FOLLOW(FG,FGSIZE,FG(3,CURN)).EQ.0
  1104.             IF (LTMP)
  1105.      +          LTMP=ZYNTYP(FG(1,FG(3,CURN))).NE.61
  1106.             IF (LTMP) THEN
  1107.                 CALL ZYCHNT(FG(1,FG(3,CURN)),
  1108.      +                      132+1)
  1109.                 CALL GFPUSH(STACK,STKSIZ,SP,CURN,5,0,MAXSP)
  1110.             ELSE
  1111.                 CALL ZUSCAN(TELSE,0,DUMMY,DESCO)
  1112.                 CALL ZUSCAN(TZEOS,0,DUMMY,DESCO)
  1113.                 CALL GFPUSH(STACK,STKSIZ,SP,CURN,4,0,MAXSP)
  1114.             END IF
  1115.             CURN=FG(3,CURN)
  1116.             STIF2=1
  1117.         ELSE IF (NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).NE.
  1118.      +           FG(3,CURN)) THEN
  1119.             CALL ZUSCAN(TELSE,0,DUMMY,DESCO)
  1120.             CALL ZUSCAN(TZEOS,0,DUMMY,DESCO)
  1121. C This does "FIXCONTROL" on the fly (the only way it should be done!)
  1122.             CALL GOTOX(FG,FGSIZE,FG(3,CURN),LNUM,DESCO)
  1123.         END IF
  1124.  
  1125.         END
  1126. C ----------------------------------------------------------------------
  1127. C
  1128. C       S T I F 3   -   Structure IF node: pt 3 (close off the IF block)
  1129. C
  1130.  
  1131.         INTEGER FUNCTION STIF3(DESCO)
  1132.         INTEGER DESCO
  1133.  
  1134. C---------------------------------------------------------
  1135. C    TOOLPACK/1    Release: 2.5
  1136. C---------------------------------------------------------
  1137. C
  1138. C  TKLAST = LAST TOKEN NUMBER
  1139. C
  1140.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  1141.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  1142.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  1143.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  1144.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  1145.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  1146.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  1147.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  1148.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  1149.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  1150.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  1151.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  1152.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  1153.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  1154.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  1155.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  1156.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  1157.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  1158.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  1159.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  1160.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  1161.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  1162.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  1163.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  1164.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  1165.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  1166.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  1167.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  1168.  
  1169.  
  1170.         INTEGER DUMMY(2)
  1171.  
  1172.         SAVE DUMMY
  1173.  
  1174.         EXTERNAL ZUSCAN
  1175.  
  1176.         DATA DUMMY/129,129/
  1177.  
  1178.         CALL ZUSCAN(TENDIF,0,DUMMY,DESCO)
  1179.         CALL ZUSCAN(TZEOS,0,DUMMY,DESCO)
  1180.         STIF3=5
  1181.  
  1182.         END
  1183. C ----------------------------------------------------------------------
  1184. C
  1185. C       S T K F O L   -   Stack calls to process "following" nodes
  1186. C
  1187.  
  1188.         SUBROUTINE STKFOL(FG,FGSIZE,CURN,STACK,STKSIZ,SP,MAXSP)
  1189.         INTEGER CURN,FGSIZE,STKSIZ,SP,MAXSP
  1190.         INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
  1191.  
  1192.         INTEGER I,J,TMP,TMP3(3),PTR
  1193.  
  1194.         TMP=SP+1
  1195.         DO 100 I=1,FGSIZE
  1196.             IF (FG(8,I).EQ.CURN) THEN
  1197.                 CALL GFPUSH(STACK,STKSIZ,SP,I,1,0,MAXSP)
  1198.             END IF
  1199.  100    CONTINUE
  1200. C
  1201. C Must sort stacked calls into "L" order, i.e. on FG(fg_number,*)
  1202. C
  1203. C Just use insertion sort as it is quite easy
  1204. C
  1205.         DO 400 I=TMP+1,SP
  1206.             PTR=TMP
  1207.  200        IF (FG(4,STACK(1,PTR)).GE.
  1208.      +          FG(4,STACK(1,I))) THEN
  1209.                 PTR=PTR+1
  1210.                 IF (PTR.LT.I) GOTO 200
  1211.             ELSE
  1212.                 TMP3(1)=STACK(1,I)
  1213.                 TMP3(2)=STACK(2,I)
  1214.                 TMP3(3)=STACK(3,I)
  1215.                 DO 300 J=I,PTR+1,-1
  1216.                     STACK(1,J)=STACK(1,J-1)
  1217.                     STACK(2,J)=STACK(2,J-1)
  1218.                     STACK(3,J)=STACK(3,J-1)
  1219.  300            CONTINUE
  1220.                 STACK(1,PTR)=TMP3(1)
  1221.                 STACK(2,PTR)=TMP3(2)
  1222.                 STACK(3,PTR)=TMP3(3)
  1223.             END IF
  1224.  400    CONTINUE
  1225.  
  1226.         END
  1227. C ----------------------------------------------------------------------
  1228. C
  1229. C       F O L L O W   -   Return the first node in the FOLLOW set
  1230. C
  1231.  
  1232.         INTEGER FUNCTION FOLLOW(FG,FGSIZE,NODE)
  1233.         INTEGER FGSIZE,NODE
  1234.         INTEGER FG(8,FGSIZE)
  1235.  
  1236.         INTEGER I
  1237.  
  1238.         FOLLOW=0
  1239.         I=1
  1240.  100    IF (FG(8,I).EQ.NODE) THEN
  1241.             IF (FOLLOW.EQ.0) THEN
  1242.                 FOLLOW=I
  1243.             ELSE IF (FG(4,I).LT.FG(4,FOLLOW)) THEN
  1244.                 FOLLOW=I
  1245.             END IF
  1246.         END IF
  1247.         IF (I.LT.FGSIZE) THEN
  1248.             I=I+1
  1249.             GOTO 100
  1250.         END IF
  1251.  
  1252.         END
  1253. C ----------------------------------------------------------------------
  1254. C
  1255. C       N E X T N D   -   Return the next node which will be output
  1256. C
  1257.  
  1258.         INTEGER FUNCTION NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP)
  1259.         INTEGER FGSIZE,CURN,STKSIZ,SP
  1260.         INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
  1261.  
  1262.         INTEGER I
  1263.  
  1264.         INTEGER FOLLOW
  1265.  
  1266.         NEXTND=FOLLOW(FG,FGSIZE,CURN)
  1267.         IF (NEXTND.EQ.0 .AND. SP.GT.0) THEN
  1268.             I=SP
  1269.  100        NEXTND=STACK(1,I)
  1270.             IF (STACK(2,I).EQ.3 .OR. STACK(2,I).EQ.4 .OR.
  1271.      +          STACK(2,I).EQ.5 .OR.
  1272.      +          STACK(2,I).EQ.2 .AND. STACK(3,I).GT.0) THEN
  1273. C at end of if clauses we jump to the follower of the if statement
  1274. C at end of repeat (not DO) we pass to the follower of the repeat
  1275.                 NEXTND=FOLLOW(FG,FGSIZE,NEXTND)
  1276. C if no follower we are ending several blocks at once ...
  1277.                 IF (NEXTND.EQ.0 .AND. I.GT.1) THEN
  1278.                     I=I-1
  1279.                     GOTO 100
  1280.                 END IF
  1281.             END IF
  1282.         END IF
  1283.  
  1284.         END
  1285. C ----------------------------------------------------------------------
  1286. C
  1287. C       G O T O X   -   Add GOTO statement to output
  1288. C
  1289.  
  1290.         SUBROUTINE GOTOX(FG,FGSIZE,NODE,LABNUM,TKDESC)
  1291.         INTEGER FGSIZE,NODE,LABNUM,TKDESC
  1292.         INTEGER FG(8,FGSIZE)
  1293.  
  1294. C---------------------------------------------------------
  1295. C    TOOLPACK/1    Release: 2.5
  1296. C---------------------------------------------------------
  1297. C
  1298. C  TKLAST = LAST TOKEN NUMBER
  1299. C
  1300.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  1301.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  1302.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  1303.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  1304.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  1305.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  1306.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  1307.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  1308.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  1309.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  1310.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  1311.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  1312.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  1313.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  1314.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  1315.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  1316.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  1317.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  1318.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  1319.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  1320.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  1321.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  1322.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  1323.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  1324.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  1325.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  1326.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  1327.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  1328.  
  1329.  
  1330.         INTEGER TEXT(8),I
  1331.         LOGICAL USERET
  1332.  
  1333.         INTEGER LABELN
  1334.  
  1335.         INTEGER ITOC,ZYNTYP,ZYUP
  1336.         EXTERNAL ITOC,ZYNTYP,ZYUP,ZUSCAN
  1337.  
  1338.         TEXT(1)=129
  1339.         USERET=FG(1,NODE).GT.0
  1340.         IF (USERET) USERET=ZYNTYP(FG(1,NODE)).EQ.6 .AND.
  1341.      +                     ZYNTYP(ZYUP(FG(1,NODE))).NE.2
  1342.         IF (USERET) THEN
  1343.             CALL ZUSCAN(TRETUR,0,TEXT,TKDESC)
  1344.         ELSE
  1345.             CALL ZUSCAN(TGOTO,0,TEXT,TKDESC)
  1346.             I=ITOC(LABELN(FG,FGSIZE,NODE,LABNUM),TEXT,7)
  1347.             CALL ZUSCAN(TDCNST,I,TEXT,TKDESC)
  1348.             TEXT(1)=129
  1349.         END IF
  1350.         CALL ZUSCAN(TZEOS,0,TEXT,TKDESC)
  1351.  
  1352.         END
  1353. C ----------------------------------------------------------------------
  1354. C
  1355. C       M K L R E F   -   Make a N_LABELREF node point correctly
  1356. C
  1357.  
  1358.         SUBROUTINE MKLREF(FG,FGSIZE,FGNODE,LABNUM,PTNODE)
  1359.         INTEGER FGSIZE,FGNODE,LABNUM,PTNODE
  1360.         INTEGER FG(8,FGSIZE)
  1361.  
  1362.         INTEGER I,TEXT(8)
  1363.  
  1364.         INTEGER LABELN
  1365.  
  1366.         INTEGER ITOC,ZYASTR,ZYASYM
  1367.         EXTERNAL ITOC,ZYASTR,ZYASYM,ZYCHDN
  1368.  
  1369.         I=ITOC(LABELN(FG,FGSIZE,FGNODE,LABNUM),TEXT,7)
  1370.         CALL ZYCHDN(PTNODE,-ZYASYM(ZYASTR(TEXT),1,1))
  1371.  
  1372.         END
  1373. C ----------------------------------------------------------------------
  1374. C
  1375. C       L A B E L N   -   Label a node (return value)
  1376. C
  1377.  
  1378.         INTEGER FUNCTION LABELN(FG,FGSIZE,NODE,LABNUM)
  1379.         INTEGER FGSIZE,NODE,LABNUM
  1380.         INTEGER FG(8,FGSIZE)
  1381.  
  1382.         INTEGER TEXT(134),SYMBOL(8),I,PTNODE,PTR
  1383.  
  1384.         INTEGER ZYNEXT,ZYDOWN,ZYNTYP,ZYCRND,ZYASTR,ZYASYM,ITOC,CTOI
  1385.         EXTERNAL ZYNEXT,ZYDOWN,ZYNTYP,ZYCRND,ZYASTR,ZYASYM,ITOC,CTOI,
  1386.      +           ZYADSN,ZYGTSY,ZYGTST,ERROR,ZYADNX
  1387.  
  1388.         PTNODE=FG(1,NODE)
  1389.         IF (PTNODE.LT.0) THEN
  1390.             IF (FG(3,NODE).EQ.0) THEN
  1391.                 LABNUM=LABNUM+10
  1392.                 IF (LABNUM.EQ.9000) LABNUM=90000
  1393. C Must check for DO - in which case label the DO not the repeat node?
  1394.                 PTNODE=FG(1,FG(2,NODE))
  1395.                 IF (PTNODE.LE.0) CALL ERROR('LABELN: BAD REPEAT')
  1396.                 IF (ZYNTYP(PTNODE).EQ.61) THEN
  1397.                     PTR=ZYDOWN(PTNODE)
  1398.                     IF (ZYNTYP(PTR).EQ.115) THEN
  1399.                         IF (LABNUM.EQ.90000) LABNUM=9000
  1400.                         LABNUM=LABNUM-10
  1401.                         CALL ZYGTSY(-ZYDOWN(ZYDOWN(PTNODE)),SYMBOL)
  1402.                         CALL ZYGTST(SYMBOL(2),TEXT)
  1403.                         I=1
  1404.                         LABELN=CTOI(TEXT,I)
  1405.                     ELSE
  1406.                         I=ITOC(LABNUM,TEXT,7)
  1407.                         CALL ZYADNX(ZYCRND(115,
  1408.      +                                     -ZYASYM(ZYASTR(TEXT),
  1409.      +                                             1,
  1410.      +                                             1)),
  1411.      +                              ZYDOWN(PTNODE))
  1412.                         CALL ZYADNX(ZYDOWN(PTNODE),
  1413.      +                              ZYNEXT(ZYDOWN(PTNODE)))
  1414.                         LABELN=LABNUM
  1415.                     END IF
  1416.                 ELSE
  1417.                     FG(3,NODE)=LABNUM
  1418.                     LABELN=ABS(FG(3,NODE))
  1419.                 END IF
  1420.             ELSE
  1421.                 LABELN=ABS(FG(3,NODE))
  1422.             END IF
  1423.         ELSE IF (ZYDOWN(PTNODE).LE.0) THEN
  1424.             LABNUM=LABNUM+10
  1425.             IF (LABNUM.EQ.9000) LABNUM=90000
  1426.             I=ITOC(LABNUM,TEXT,7)
  1427.             CALL ZYADSN(PTNODE,ZYCRND(115,
  1428.      +                                -ZYASYM(ZYASTR(TEXT),1,1)))
  1429.             LABELN=LABNUM
  1430.         ELSE IF (ZYNTYP(ZYDOWN(PTNODE)).EQ.115) THEN
  1431.             CALL ZYGTSY(-ZYDOWN(ZYDOWN(PTNODE)),SYMBOL)
  1432.             CALL ZYGTST(SYMBOL(2),TEXT)
  1433.             I=1
  1434.             LABELN=CTOI(TEXT,I)
  1435.         ELSE
  1436.             LABNUM=LABNUM+10
  1437.             IF (LABNUM.EQ.9000) LABNUM=90000
  1438.             I=ITOC(LABNUM,TEXT,7)
  1439.             CALL ZYADNX(ZYCRND(115,
  1440.      +                         -ZYASYM(ZYASTR(TEXT),1,1)),
  1441.      +                  ZYDOWN(PTNODE))
  1442.             CALL ZYADNX(ZYDOWN(PTNODE),ZYNEXT(ZYDOWN(PTNODE)))
  1443.             LABELN=LABNUM
  1444.         END IF
  1445.  
  1446.         END
  1447. C ----------------------------------------------------------------------
  1448. C
  1449. C       I N V C O N   -   Invert a condition
  1450. C
  1451.  
  1452.         SUBROUTINE INVCON(COND)
  1453.         INTEGER COND
  1454.  
  1455.         INTEGER STKSIZ
  1456.         PARAMETER(STKSIZ=15)
  1457.  
  1458.         INTEGER NODE,TMP,TMP2,STACK(STKSIZ),SP
  1459.  
  1460.         INTEGER ZYNTYP,ZYCRND,ZYDOWN,ZYNEXT
  1461.         EXTERNAL ZYNTYP,ZYCRND,ZYDOWN,ZYNEXT,ZYCHNT,ZYREPL,ZYADSN,REMARK
  1462.  
  1463.         NODE=COND
  1464.         SP=0
  1465. C Negate this subexpression
  1466.  100    IF (ZYNTYP(NODE).EQ.91) THEN
  1467.             CALL ZYCHNT(NODE,92)
  1468.         ELSE IF (ZYNTYP(NODE).EQ.92) THEN
  1469.             CALL ZYCHNT(NODE,91)
  1470.         ELSE IF (ZYNTYP(NODE).EQ.90) THEN
  1471.             CALL ZYCHNT(NODE,93)
  1472.         ELSE IF (ZYNTYP(NODE).EQ.89) THEN
  1473.             CALL ZYCHNT(NODE,94)
  1474.         ELSE IF (ZYNTYP(NODE).EQ.94) THEN
  1475.             CALL ZYCHNT(NODE,89)
  1476.         ELSE IF (ZYNTYP(NODE).EQ.93) THEN
  1477.             CALL ZYCHNT(NODE,90)
  1478.         ELSE IF (ZYNTYP(NODE).EQ.84) THEN
  1479.             CALL ZYCHNT(NODE,85)
  1480.         ELSE IF (ZYNTYP(NODE).EQ.85) THEN
  1481.             CALL ZYCHNT(NODE,84)
  1482.         ELSE IF (ZYNTYP(NODE).EQ.88) THEN
  1483.             TMP=ZYDOWN(NODE)
  1484.             CALL ZYREPL(NODE,TMP)
  1485.         ELSE IF (ZYNTYP(NODE).EQ.86 .OR.
  1486.      +           ZYNTYP(NODE).EQ.87) THEN
  1487. C Apply distributive law: NOT(A OR B) = NOT(A) AND NOT(B)
  1488. C                     or: NOT(A AND B) = NOT(A) AND NOT(B)
  1489. C (but not if the both sub-expressions are simple -- we would rather
  1490. C  get .NOT.(A.OR.B) than .NOT.A.AND..NOT.B; simple extends to being
  1491. C  other conjunctions or disjunctions since we can't simplify them
  1492. C  either)
  1493.             IF ((ZYNTYP(ZYDOWN(NODE)).EQ.104 .OR.
  1494.      +          ZYNTYP(ZYDOWN(NODE)).EQ.108 .OR.
  1495.      +          ZYNTYP(ZYDOWN(NODE)).EQ.119 .OR.
  1496.      +          ZYNTYP(ZYDOWN(NODE)).EQ.109 .OR.
  1497.      +          ZYNTYP(ZYDOWN(NODE)).EQ.87 .OR.
  1498.      +          ZYNTYP(ZYDOWN(NODE)).EQ.86) .AND.
  1499.      +          (ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.104 .OR.
  1500.      +          ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.108 .OR.
  1501.      +          ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.119 .OR.
  1502.      +          ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.109 .OR.
  1503.      +          ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.87 .OR.
  1504.      +          ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.86)) THEN
  1505. C Just a simple case of (A .AND/OR. B) - make it .NOT(A .AND/OR. B)
  1506.                 TMP=ZYCRND(101,0)
  1507.                 CALL ZYREPL(NODE,TMP)
  1508.                 CALL ZYADSN(TMP,NODE)
  1509.                 NODE=ZYCRND(88,0)
  1510.                 CALL ZYREPL(TMP,NODE)
  1511.                 CALL ZYADSN(NODE,TMP)
  1512.             ELSE
  1513.                 IF (ZYNTYP(NODE).EQ.87) THEN
  1514.                     CALL ZYCHNT(NODE,86)
  1515.                 ELSE
  1516.                     CALL ZYCHNT(NODE,87)
  1517.                 END IF
  1518.                 SP=SP+2
  1519.                 STACK(SP-1)=ZYDOWN(NODE)
  1520.                 STACK(SP)=ZYNEXT(ZYDOWN(NODE))
  1521.                 IF (ZYNTYP(NODE).EQ.87) THEN
  1522. C If we just increased the priority (by changing .OR. to .AND.)
  1523. C then we must parenthesise any subexpressions which have as their
  1524. C top node .AND. (which we will change to .OR.).
  1525.                     IF (ZYNTYP(STACK(SP-1)).EQ.87) THEN
  1526.                         TMP=ZYCRND(101,0)
  1527.                         CALL ZYREPL(STACK(SP-1),TMP)
  1528.                         CALL ZYADSN(TMP,STACK(SP-1))
  1529.                     END IF
  1530.                     IF (ZYNTYP(STACK(SP)).EQ.87) THEN
  1531.                         TMP=ZYCRND(101,0)
  1532.                         CALL ZYREPL(STACK(SP),TMP)
  1533.                         CALL ZYADSN(TMP,STACK(SP))
  1534.                     END IF
  1535.                 END IF
  1536.             END IF
  1537.         ELSE IF (ZYNTYP(NODE).EQ.101) THEN
  1538.             NODE=ZYDOWN(NODE)
  1539.             GOTO 100
  1540.         ELSE
  1541.             IF (ZYNTYP(NODE).NE.104 .AND.
  1542.      +          ZYNTYP(NODE).NE.108 .AND.
  1543.      +          ZYNTYP(NODE).NE.119 .AND.
  1544.      +          ZYNTYP(NODE).NE.109)
  1545.      +          CALL REMARK(
  1546.      +'Internal Error: UNUSUAL CONDITION FOUND - CONTINUING')
  1547.             TMP=ZYCRND(88,0)
  1548.             CALL ZYREPL(NODE,TMP)
  1549.             CALL ZYADSN(TMP,NODE)
  1550.         END IF
  1551.         IF (SP.GT.0) THEN
  1552.             NODE=STACK(SP)
  1553.             SP=SP-1
  1554.             GOTO 100
  1555.         END IF
  1556. C
  1557. C Finished condition reversal -- but now reparse it to factor out .NOT.
  1558. C operators -- i.e. turn .NOT.(A).AND..NOT(B) into .NOT.(A.OR.B) and
  1559. C similarly with .OR.
  1560. C (The reason this gets produced above is that when reversing we want to
  1561. C  turn A.GT.B .OR. C.EQ.0 into A.LE.B .AND. C.NE.0
  1562. C                    instead of .NOT.(A.GT.B .OR. C.EQ.0)
  1563. C
  1564.         NODE=COND
  1565.  200    IF (ZYNTYP(NODE).EQ.87 .OR. ZYNTYP(NODE).EQ.86) THEN
  1566.             IF (ZYNTYP(ZYDOWN(NODE)).EQ.88 .AND.
  1567.      +          ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.88) THEN
  1568.                 TMP=ZYDOWN(NODE)
  1569.                 CALL ZYREPL(TMP,ZYDOWN(TMP))
  1570.                 CALL ZYREPL(NODE,TMP)
  1571.                 CALL ZYADSN(TMP,NODE)
  1572.                 TMP=ZYNEXT(ZYDOWN(NODE))
  1573.                 CALL ZYREPL(TMP,ZYDOWN(TMP))
  1574.                 CALL ZYREPL(NODE,TMP)
  1575.                 CALL ZYADSN(TMP,NODE)
  1576.                 CALL ZYCHNT(TMP,101)
  1577.                 IF (ZYNTYP(NODE).EQ.87) THEN
  1578.                     CALL ZYCHNT(NODE,86)
  1579.                 ELSE
  1580.                     CALL ZYCHNT(NODE,87)
  1581. C Once again, changing .OR. to .AND. may change meaning...
  1582.                     IF (ZYDOWN(NODE).EQ.86) THEN
  1583.                         TMP=ZYCRND(101,0)
  1584.                         CALL ZYREPL(ZYDOWN(NODE),TMP)
  1585.                         CALL ZYADSN(TMP,ZYDOWN(NODE))
  1586.                     END IF
  1587.                     IF (ZYNEXT(ZYDOWN(NODE)).EQ.86) THEN
  1588.                         TMP=ZYCRND(101,0)
  1589.                         CALL ZYREPL(ZYNEXT(ZYDOWN(NODE)),TMP)
  1590.                         CALL ZYADSN(TMP,ZYNEXT(ZYDOWN(NODE)))
  1591.                     END IF
  1592.                 END IF
  1593.             ELSE
  1594.                 IF (ZYNTYP(ZYDOWN(NODE)).EQ.87 .OR.
  1595.      +              ZYNTYP(ZYDOWN(NODE)).EQ.86) THEN
  1596.                     SP=SP+1
  1597.                     STACK(SP)=ZYDOWN(NODE)
  1598.                 END IF
  1599.                 IF (ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.87 .OR.
  1600.      +              ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.86) THEN
  1601.                     SP=SP+1
  1602.                     STACK(SP)=ZYNEXT(ZYDOWN(NODE))
  1603.                 END IF
  1604.             END IF
  1605.         END IF
  1606.         IF (SP.GT.0) THEN
  1607.             NODE=STACK(SP)
  1608.             SP=SP-1
  1609.             GOTO 200
  1610.         END IF
  1611.  
  1612.         END
  1613. C ----------------------------------------------------------------------
  1614. C
  1615. C       R E A C H   -   Calculate REACH set for IF node
  1616. C
  1617.  
  1618.         SUBROUTINE REACH(FG,FGSIZE,NODE,NEXTN,STACK,STKSIZ,SP,MAXSP)
  1619.         INTEGER FGSIZE,NODE,NEXTN,STKSIZ,SP,MAXSP
  1620.         INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
  1621.  
  1622.         INTEGER RSTKSZ
  1623.         PARAMETER (RSTKSZ=26)
  1624.  
  1625.         INTEGER REACHN,RSTACK(RSTKSZ),RSP,PTR,NUMBER,I
  1626.  
  1627. C RSTACK(nn) = "IF" node we are currently following true branch of
  1628.  
  1629.         LOGICAL NESTED
  1630.  
  1631.         EXTERNAL ERROR
  1632.  
  1633.         REACHN=0
  1634.         RSP=0
  1635.         PTR=NODE
  1636.  
  1637.  100    CONTINUE
  1638. C Here to process a nested node
  1639.         FG(7,PTR)=-FG(7,PTR)
  1640.         NUMBER=FG(4,PTR)
  1641. C Remember the numbering of it so we can detect backward refs
  1642.         IF (FG(2,PTR).LE.0) THEN
  1643. C Give up if it is an END or case
  1644.             GOTO 666
  1645.         ELSE IF (FG(3,PTR).GT.0) THEN
  1646. C An IF node -- push false branch (for later processing),
  1647. C then visit true branch; give up if too deeply nested.
  1648.             IF (RSP.EQ.RSTKSZ) GOTO 666
  1649.             RSP=RSP+1
  1650.             RSTACK(RSP)=PTR
  1651.             PTR=FG(2,PTR)
  1652. C If first node on "true" branch has only one inarc, we know it must
  1653. C be nested (if this is the forward inarc that is)
  1654.             IF (FG(7,PTR).EQ.1 .AND.
  1655.      +          NUMBER.LT.FG(4,PTR)) GOTO 100
  1656.         ELSE IF (FG(1,PTR).EQ.-1) THEN
  1657. C Repeat node - so first node of repeat is always properly nested
  1658.             PTR=FG(2,PTR)
  1659.             GOTO 100
  1660.         ELSE
  1661. C SLC node - visit next in sequence
  1662. C next node is always properly nested if it is in the follow set
  1663.             IF (FG(8,FG(2,PTR)).EQ.PTR) THEN
  1664.                 PTR=FG(2,PTR)
  1665.                 GOTO 100
  1666.             END IF
  1667.             PTR=FG(2,PTR)
  1668.         END IF
  1669.  
  1670.  200    CONTINUE
  1671. C Here to visit a node which may or may not be properly nested
  1672. C (but not if we have already done so)
  1673.         IF (FG(7,PTR).GE.0) THEN
  1674.             IF (NESTED(FG,FGSIZE,PTR,NODE)) THEN
  1675. C Yes it is - process it as such (unless it is a backward reference)
  1676.                 IF (FG(4,PTR).GT.NUMBER) GOTO 100
  1677.             ELSE IF (REACHN.EQ.0) THEN
  1678. C No it isn't nested -- and the REACH set is empty, so remember it
  1679.                 REACHN=PTR
  1680.             ELSE IF (REACHN.NE.PTR) THEN
  1681. C Non-singleton REACH set, so return now
  1682.                 GOTO 666
  1683.             END IF
  1684.         END IF
  1685.  
  1686. C Finished processing current branch -- try next one
  1687.         IF (RSP.GT.0) THEN
  1688.             PTR=FG(3,RSTACK(RSP))
  1689.             NUMBER=FG(4,RSTACK(RSP))
  1690.             RSP=RSP-1
  1691. C Make sure node is nested though...
  1692.             GOTO 200
  1693.         END IF
  1694.  
  1695. C Finished REACH set calculation -- is it empty?
  1696.         IF (REACHN.EQ.0) THEN
  1697.             CALL ERROR('EMPTY REACH SET')
  1698.         ELSE IF (REACHN.NE.NEXTN) THEN
  1699.             CALL GFPUSH(STACK,STKSIZ,SP,REACHN,6,0,MAXSP)
  1700.         END IF
  1701.  
  1702.  666    DO 300 I=1,FGSIZE
  1703.             IF (FG(7,I).LT.0) FG(7,I)=-FG(7,I)
  1704.  300    CONTINUE
  1705.  
  1706.         END
  1707. C ----------------------------------------------------------------------
  1708. C
  1709. C       N E S T E D   -   Is a node nested within another?
  1710. C
  1711. C       (Is ANODE nested within BNODE)
  1712. C
  1713.  
  1714.         LOGICAL FUNCTION NESTED(FG,FGSIZE,ANODE,BNODE)
  1715.         INTEGER FGSIZE,ANODE,BNODE
  1716.         INTEGER FG(8,FGSIZE)
  1717.  
  1718.         INTEGER DOMPTR
  1719.  
  1720. C ANODE is nested within BNODE if and only if
  1721. C    (1) DOM**N(ANODE)=BNODE for some N, and
  1722. C    (2) ANODE,DOM**N(ANODE) not in FOLLOW(BNODE)
  1723.  
  1724.         IF (FG(8,ANODE).EQ.BNODE) THEN
  1725.             NESTED=.FALSE.
  1726.         ELSE
  1727.             DOMPTR=FG(6,ANODE)
  1728.  100        IF (DOMPTR.NE.0 .AND. DOMPTR.NE.BNODE) THEN
  1729.                 IF (FG(8,DOMPTR).NE.BNODE) THEN
  1730.                     DOMPTR=FG(6,DOMPTR)
  1731.                     GOTO 100
  1732.                 END IF
  1733.             END IF
  1734.             NESTED=DOMPTR.EQ.BNODE
  1735.         END IF
  1736.  
  1737.         END
  1738. C ----------------------------------------------------------------------
  1739. C
  1740. C       O U T F M T   -   Output the FORMAT statements
  1741. C
  1742.  
  1743.         SUBROUTINE OUTFMT(PUPTR,IODCMT,DESCO)
  1744.         INTEGER PUPTR,IODCMT,DESCO
  1745.  
  1746.         INTEGER PTR
  1747.  
  1748.         INTEGER ZYDOWN,ZYNEXT,ZYNTYP
  1749.         EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,YSTMT
  1750.  
  1751.         PTR=ZYDOWN(PUPTR)
  1752.  
  1753.  100    IF (ZYNTYP(PTR).EQ.78) THEN
  1754.             CALL COMMNT(PTR,IODCMT,DESCO)
  1755.             CALL YSTMT(PTR,DESCO)
  1756.         END IF
  1757.         PTR=ZYNEXT(PTR)
  1758.         IF (PTR.NE.0) GOTO 100
  1759.  
  1760.         END
  1761. C ----------------------------------------------------------------------
  1762. C
  1763. C       C K D E A D   -   Check a flowgraph for dead code
  1764. C
  1765.  
  1766.         SUBROUTINE CKDEAD(FG,FGSIZE,PUROOT,IODCMT,DESCO)
  1767.         INTEGER FGSIZE,STARTN,PUROOT,IODCMT,DESCO
  1768.         INTEGER FG(8,FGSIZE)
  1769.  
  1770. C---------------------------------------------------------
  1771. C    TOOLPACK/1    Release: 2.5
  1772. C---------------------------------------------------------
  1773. C
  1774. C  TKLAST = LAST TOKEN NUMBER
  1775. C
  1776.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  1777.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  1778.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  1779.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  1780.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  1781.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  1782.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  1783.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  1784.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  1785.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  1786.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  1787.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  1788.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  1789.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  1790.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  1791.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  1792.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  1793.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  1794.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  1795.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  1796.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  1797.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  1798.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  1799.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  1800.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  1801.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  1802.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  1803.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  1804.  
  1805.  
  1806.         INTEGER I,SYMBOL(8),TEXT(134),WARNCM(31)
  1807.         LOGICAL CMWRND
  1808.  
  1809.         SAVE WARNCM
  1810.  
  1811.         INTEGER ZYGTXF,ZYPUSY,ZYNTYP,ZYNEXT
  1812.         EXTERNAL ZYGTXF,ZYPUSY,ZYNTYP,ZYNEXT,ZCHOUT,ZPTINT,ZYGTSY,
  1813.      +           ZYGTST,PUTLIN,ZMESS,ZUSCAN,PUTCH
  1814.  
  1815. C "*$st$ Unreachable comments ..."
  1816.  
  1817.         DATA WARNCM/42,36,115,116,36,32,85,110,114,
  1818.      +              101,97,99,104,97,98,108,101,32,99,
  1819.      +              111,109,109,101,110,116,115,32,46,
  1820.      +              46,46,129/
  1821.  
  1822.         CMWRND=.FALSE.
  1823.         DO 100 I=1,FGSIZE
  1824.             IF (FG(4,I).EQ.0) THEN
  1825.                 IF (ZYNTYP(FG(1,I)).EQ.131) THEN
  1826.                     IF (.NOT.CMWRND) THEN
  1827.                         CALL ZUSCAN(TCMMNT,30,WARNCM,DESCO)
  1828.                         CALL ZCHOUT(
  1829.      +'Unreachable comments placed before END statement in ',2)
  1830.                         CALL ZYGTSY(ZYPUSY(PUROOT),SYMBOL)
  1831.                         CALL ZYGTST(SYMBOL(2),TEXT)
  1832.                         CALL PUTLIN(TEXT,2)
  1833.                         CALL PUTCH(10,2)
  1834.                     END IF
  1835.                     CMWRND=.TRUE.
  1836.                     CALL COMMNT(FG(1,I),IODCMT,DESCO)
  1837.                 ELSE
  1838.                     CALL ZCHOUT('Unreachable statement ',2)
  1839.                     CALL ZPTINT(ZYGTXF(FG(1,I)),1,2)
  1840.                     CALL ZCHOUT(' in ',2)
  1841.                     CALL ZYGTSY(ZYPUSY(PUROOT),SYMBOL)
  1842.                     CALL ZYGTST(SYMBOL(2),TEXT)
  1843.                     CALL PUTLIN(TEXT,2)
  1844.                     CALL ZMESS(' eliminated..',2)
  1845.                 END IF
  1846.             END IF
  1847.  100    CONTINUE
  1848.  
  1849.         END
  1850. C ----------------------------------------------------------------------
  1851. C
  1852. C       F L A T T N   -   Flatten (output) a program-unit, unchanged
  1853. C
  1854.  
  1855.         SUBROUTINE FLATTN(PUROOT,IODCMT,DESCO)
  1856.         INTEGER PUROOT,IODCMT,DESCO
  1857.  
  1858.         INTEGER PTR
  1859.  
  1860.         INTEGER ZYDOWN,ZYNEXT
  1861.         EXTERNAL ZYDOWN,ZYNEXT,YSTMT
  1862.  
  1863.         PTR=ZYDOWN(PUROOT)
  1864.  100    CALL COMMNT(PTR,IODCMT,DESCO)
  1865.         CALL YSTMT(PTR,DESCO)
  1866.         PTR=ZYNEXT(PTR)
  1867.         IF (PTR.NE.0) GOTO 100
  1868.  
  1869.         END
  1870. C ----------------------------------------------------------------------
  1871. C
  1872. C       C O M M N T   -   Output comments associated with a statement
  1873. C
  1874.  
  1875.         SUBROUTINE COMMNT(NODE,IODCMT,DESCO)
  1876.         INTEGER NODE,IODCMT,DESCO
  1877.  
  1878. C---------------------------------------------------------
  1879. C    TOOLPACK/1    Release: 2.5
  1880. C---------------------------------------------------------
  1881. C
  1882. C  TKLAST = LAST TOKEN NUMBER
  1883. C
  1884.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  1885.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  1886.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  1887.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  1888.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  1889.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  1890.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  1891.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  1892.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  1893.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  1894.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  1895.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  1896.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  1897.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  1898.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  1899.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  1900.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  1901.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  1902.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  1903.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  1904.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  1905.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  1906.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  1907.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  1908.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  1909.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  1910.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  1911.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  1912.  
  1913.  
  1914.         INTEGER TEXT(134),STMTNO
  1915.  
  1916.         INTEGER ZYGTCM,ZYGNCM,ZYGTXF,LENGTH
  1917.         EXTERNAL ZYGTCM,ZYGNCM,ZYGTXF,LENGTH,ZUSCAN
  1918.  
  1919.         STMTNO=ZYGTXF(NODE)
  1920.         IF (STMTNO.NE.0) THEN
  1921.             IF (ZYGTCM(IODCMT,STMTNO,TEXT).NE.-100) THEN
  1922.  100            CALL ZUSCAN(TCMMNT,LENGTH(TEXT),TEXT,DESCO)
  1923.                 IF (ZYGNCM(IODCMT,TEXT).NE.-100) GOTO 100
  1924.             END IF
  1925.         END IF
  1926.  
  1927.         END
  1928. C ----------------------------------------------------------------------
  1929. C
  1930. C       E R R O U T   -   Produce error/warning message
  1931. C
  1932.  
  1933.         SUBROUTINE ERROUT(STRING,STPTR)
  1934.         CHARACTER*(*) STRING
  1935.         INTEGER STPTR
  1936.  
  1937.         INTEGER TEXT(1322),SYMBOL(8)
  1938.  
  1939.         INTEGER ZYGTXF,ZYDOWN,ZYUP,ZYPUSY
  1940.         EXTERNAL ZYGTXF,ZYDOWN,ZYUP,ZYPUSY,ZCHOUT,ZPTINT,ZYGTSY,ZYGTST,
  1941.      +           PUTLIN,PUTCH
  1942.  
  1943.         CALL ZCHOUT(STRING,2)
  1944.         CALL ZCHOUT(' at statement ',2)
  1945.         CALL ZPTINT(ZYGTXF(STPTR)-ZYGTXF(ZYDOWN(ZYUP(STPTR)))+1,1,
  1946.      +              2)
  1947.         CALL ZCHOUT(' in ',2)
  1948.         CALL ZYGTSY(ZYPUSY(ZYUP(STPTR)),SYMBOL)
  1949.         CALL ZYGTST(SYMBOL(2),TEXT)
  1950.         CALL PUTLIN(TEXT,2)
  1951.         CALL PUTCH(10,2)
  1952.  
  1953.         END
  1954.